home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0075_Character Editor.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  9KB  |  343 lines
  1. {
  2. This program allows you to create characters using the GRAPHICS unit
  3. supplied otherwise with the SWAG routines. If you have any questions
  4. on these routines, please let me know.
  5.  
  6. MICHAEL HOENIE - Intelec Pascal Moderator.  }
  7.  
  8. program charedit;
  9.  
  10. uses
  11.   dos, crt;
  12.  
  13. const
  14.   numnewchars = 1;
  15.  
  16. type
  17.   string80 = string[80];
  18.  
  19. var { all variables inside of the game }
  20.   char_map : array [1..16] of string[8];
  21.   xpos,
  22.   ypos,
  23.   x, y, z  : integer;
  24.   out,
  25.   incom    : string[255];
  26.   charout  : char;
  27.   outfile  : text;
  28.   char     : array [1..16] of byte;
  29.  
  30. procedure loadchar;
  31. type
  32.   bytearray = array [0..15] of byte;
  33.   chararray = record
  34.     charnum  : byte;
  35.     chardata : bytearray;
  36.   end;
  37. var
  38.   regs     : registers;
  39.   newchars : chararray;
  40. begin
  41.   with regs do
  42.   begin
  43.     ah := $11;   { video sub-Function $11 }
  44.     al := $0;    { Load Chars to table $0 }
  45.     bh := $10;   { number of Bytes per Char $10 }
  46.     bl := $0;    { Character table to edit }
  47.     cx := $1;    { number of Chars we're definig $1}
  48.     dx := 176;
  49.     for x := 0 to 15 do
  50.       newchars.chardata[x] := char[x + 1];
  51.     es := seg(newchars.chardata);
  52.     bp := ofs(newchars.chardata);
  53.     intr($10, regs);
  54.   end;
  55. end;
  56.  
  57. Procedure FastWrite(Col, Row, Attrib : Byte; Str : string80);
  58. begin
  59.   inline
  60.     ($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/
  61.      $03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/
  62.      $8a/$8e/str/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/
  63.      $1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/
  64.      $8a/$9A/str/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/
  65.      $89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/
  66.      $8E/$DA/$46/$8a/$9A/str/$89/$1D/$47/$47/$E2/$F5/$1F);
  67. end;
  68.  
  69. procedure initalize;
  70. begin
  71.   for x := 1 to 16 do
  72.     char[x] := 0;
  73.   xpos := 1;
  74.   ypos := 1;
  75.   for x := 1 to 16 do
  76.     char_map[x] := '        '; { clear it out }
  77. end;
  78.  
  79. procedure display_screen;
  80. begin
  81.   loadchar;
  82.   fastwrite(1,1,$1F,'         CHAREDIT - By Michael S. Hoenie         ');
  83.   fastwrite(1,2, $7,'      12345678   ┌─────Data');
  84.   fastwrite(1,3, $7,'     ▄▄▄▄▄▄▄▄▄▄  │');
  85.   fastwrite(1,4, $7,'   1 █        █ 000');
  86.   fastwrite(1,5, $7,'   2 █        █ 000 Single:  ░');
  87.   fastwrite(1,6, $7,'   3 █        █ 000');
  88.   fastwrite(1,7, $7,'   4 █        █ 000 Multiple:');
  89.   fastwrite(1,8, $7,'   5 █        █ 000');
  90.   fastwrite(1,9, $7,'   6 █        █ 000     ░░░░░░');
  91.   fastwrite(1,10,$7,'   7 █        █ 000     ░░░░░░');
  92.   fastwrite(1,11,$7,'   8 █        █ 000     ░░░░░░');
  93.   fastwrite(1,12,$7,'   9 █        █ 000                    U            ');
  94.   fastwrite(1,13,$7,'  10 █        █ 000 f1=paint spot      │    MOVEMENT');
  95.   fastwrite(1,14,$7,'  11 █        █ 000 f2=erase spot   L──┼──R         ');
  96.   fastwrite(1,15,$7,'  12 █        █ 000  S=save char       │            ');
  97.   fastwrite(1,16,$7,'  13 █        █ 000  Q=quit editor     D');
  98.   fastwrite(1,17,$7,'  14 █        █ 000  C=reset char    r=scroll-right');
  99.   fastwrite(1,18,$7,'  15 █        █ 000  l=scroll-left');
  100.   fastwrite(1,19,$7,'  16 █        █ 000  r=scroll-right');
  101.   fastwrite(1,20,$7,'     ▀▀▀▀▀▀▀▀▀▀      u=scroll-up');
  102. end;
  103.  
  104. procedure calculate_char;
  105. begin
  106.   for x := 1 to 16 do
  107.     char[x] := 0;
  108.   for x := 1 to 16 do
  109.   begin
  110.     fastwrite(7, x + 3, $4F, char_map[x]);
  111.     incom := char_map[x];
  112.       y := 0;
  113.     if copy(incom, 1, 1) = '█' then y := y + 1;
  114.     if copy(incom, 2, 1) = '█' then y := y + 2;
  115.     if copy(incom, 3, 1) = '█' then y := y + 4;
  116.     if copy(incom, 4, 1) = '█' then y := y + 8;
  117.     if copy(incom, 5, 1) = '█' then y := y + 16;
  118.     if copy(incom, 6, 1) = '█' then y := y + 32;
  119.     if copy(incom, 7, 1) = '█' then y := y + 64;
  120.     if copy(incom, 8, 1) = '█' then y := y + 128;
  121.     char[x] := y;
  122.   end;
  123.   for x := 1 to 16 do
  124.   begin
  125.     str(char[x], incom);
  126.     while length(incom) < 3 do
  127.       insert(' ', incom, 1);
  128.     fastwrite(17, x + 3, $4E, incom);
  129.   end;
  130.   loadchar;
  131. end;
  132.  
  133. procedure do_online;
  134. var
  135.   done : boolean;
  136.   int1,
  137.   int2,
  138.   int3 : integer;
  139. begin
  140.   done := false;
  141.   int1 := 0;
  142.   int2 := 0;
  143.   int3 := 0;
  144.   while not done do
  145.   begin
  146.     incom := copy(char_map[ypos], xpos, 1);
  147.     int1  := int1 + 1;
  148.     if int1 > 150 then
  149.       int2 := int2 + 1;
  150.     if int2 > 4 then
  151.     begin
  152.       int1 := 0;
  153.       int3 := int3 + 1;
  154.       if int3 > 2 then
  155.         int3 := 1;
  156.       case int3 of
  157.         1 : fastwrite(xpos + 6, ypos + 3, $F, incom);
  158.         2 : fastwrite(xpos + 6, ypos + 3, $F, '');
  159.       end;
  160.     end;
  161.  
  162.     if keypressed then
  163.     begin
  164.       charout := readkey;
  165.       out     := charout;
  166.       if ord(out[1]) = 0 then
  167.       begin
  168.         charout := readkey;
  169.         out     := charout;
  170.         fastwrite(60, 2, $2F, out);
  171.  
  172.         case out[1] of
  173.           ';' :
  174.           begin { F1 }
  175.             delete(char_map[ypos], xpos, 1);
  176.             insert('█', char_map[ypos], xpos);
  177.             calculate_char;
  178.           end;
  179.  
  180.           '<':
  181.           begin { F2 }
  182.             delete(char_map[ypos], xpos, 1);
  183.             insert(' ', char_map[ypos], xpos);
  184.             calculate_char;
  185.           end;
  186.  
  187.           'H':
  188.           begin { up }
  189.             ypos := ypos - 1;
  190.             if ypos < 1 then
  191.               ypos := 16;
  192.             calculate_char;
  193.           end;
  194.  
  195.           'P':
  196.           begin { down }
  197.             ypos := ypos + 1;
  198.             if ypos > 16 then
  199.               ypos := 1;
  200.             calculate_char;
  201.           end;
  202.  
  203.           'K':
  204.           begin { left }
  205.             xpos := xpos - 1;
  206.             if xpos < 1 then
  207.               xpos := 8;
  208.             calculate_char;
  209.           end;
  210.  
  211.           'M':
  212.           begin { right }
  213.             xpos := xpos + 1;
  214.             if xpos > 8 then
  215.               xpos := 1;
  216.             calculate_char;
  217.           end;
  218.         end;
  219.       end
  220.       else
  221.       begin { regular keys }
  222.  
  223.         case out[1] of
  224.           'Q', 'q':
  225.           begin { done }
  226.             clrscr;
  227.             write('Are you SURE you want to quit? (Y/n) ? ');
  228.             readln(incom);
  229.             case incom[1] of
  230.               'Y', 'y' : done := true;
  231.             end;
  232.             clrscr;
  233.             display_screen;
  234.             calculate_char;
  235.           end;
  236.  
  237.           'S','s':
  238.           begin { save }
  239.             assign(outfile, 'chardata.txt');
  240.             {$i-} reset(outfile) {$i+};
  241.             if (ioresult) >= 1 then
  242.               rewrite(outfile);
  243.             append(outfile);
  244.             writeln(outfile, 'Character Char:');
  245.             writeln(outfile, '');
  246.             writeln(outfile, '       12345678');
  247.             for x := 1 to 16 do
  248.             begin
  249.               str(x, out);
  250.               while length(out) < 6 do
  251.                 insert(' ', out, 1);
  252.               writeln(outfile, out + char_map[x]);
  253.             end;
  254.             writeln(outfile, '');
  255.             write(outfile, 'Chardata:');
  256.             for x := 1 to 15 do
  257.             begin
  258.               str(char[x], incom);
  259.               write(outfile, incom + ',');
  260.             end;
  261.             str(char[16], incom);
  262.             writeln(outfile, incom);
  263.             writeln(outfile, '-----------------------------');
  264.             close(outfile);
  265.             clrscr;
  266.             writeln('File was saved under CHARDATA.TXT.');
  267.             writeln;
  268.             write('Press ENTER to continue ? ');
  269.             readln(incom);
  270.             clrscr;
  271.             display_screen;
  272.             calculate_char;
  273.           end;
  274.  
  275.           'U','u':
  276.           begin { move entire char up }
  277.             incom := char_map[1];
  278.             for x := 2 to 16 do
  279.               char_map[x - 1] := char_map[x];
  280.             char_map[16] := incom;
  281.             calculate_char;
  282.           end;
  283.  
  284.           'R','r':
  285.           begin { move entire char to the right }
  286.             for x := 1 to 16 do
  287.             begin
  288.               out := copy(char_map[x], 8, 1);
  289.               incom := copy(char_map[x], 1, 7);
  290.               char_map[x] := out + incom;
  291.             end;
  292.             calculate_char;
  293.           end;
  294.  
  295.           'L','l':
  296.           begin { move entire char to the left }
  297.             for x := 1 to 16 do
  298.             begin
  299.               out := copy(char_map[x], 1, 1);
  300.               incom := copy(char_map[x], 2, 7);
  301.               char_map[x] := incom + out;
  302.             end;
  303.             calculate_char;
  304.           end;
  305.  
  306.           'D','d':
  307.           begin { move entire char down }
  308.             incom := char_map[16];
  309.             for x := 16 downto 2 do
  310.               char_map[x] := char_map[x - 1];
  311.             char_map[1] := incom;
  312.             calculate_char;
  313.           end;
  314.  
  315.           'C','c':
  316.           begin { reset }
  317.             clrscr;
  318.             write('Are you SURE you want to clear it? (Y/n) ? ');
  319.             readln(incom);
  320.             case incom[1] of
  321.               'Y','y' : initalize;
  322.             end;
  323.             clrscr;
  324.             display_screen;
  325.             calculate_char;
  326.           end;
  327.  
  328.         end;
  329.       end;
  330.     end;
  331.   end;
  332. end;
  333.  
  334. begin
  335.   textmode(c80);
  336.   initalize;
  337.   display_screen;
  338.   calculate_char;
  339.   do_online;
  340.   clrscr;
  341.   writeln('Thanks for using CHAREDIT!');
  342. end.
  343.